package frege.control.Arrow where


--import Control.Monad.Fix
import frege.control.Category

infixr 5 `<+>`
infixr 3 `***`
infixr 3 `&&&`
infixr 2 `+++`
infixr 2 `|||`
infixr 1 `^>>` `>>^`
infixr 1 `^<<` `<<^`

-- | The basic arrow class.
--
-- Minimal complete definition: 'arr' and 'first', satisfying the laws
--
--  * @'arr' id = 'id'@
--
--  * @'arr' (f >>> g) = 'arr' f >>> 'arr' g@
--
--  * @'first' ('arr' f) = 'arr' ('first' f)@
--
--  * @'first' (f >>> g) = 'first' f >>> 'first' g@
--
--  * @'first' f >>> 'arr' 'fst' = 'arr' 'fst' >>> f@
--
--  * @'first' f >>> 'arr' ('id' *** g) = 'arr' ('id' *** g) >>> 'first' f@
--
--  * @'first' ('first' f) >>> 'arr' 'assoc' = 'arr' 'assoc' >>> 'first' f@
--
-- where
--
-- > assoc ((a,b),c) = (a,(b,c))
--
-- The other combinators have sensible default definitions,
-- which may be overridden for efficiency.

class Arrow Category a => a where

    -- | Lift a function to an arrow.
    arr :: (b -> c) -> a b c

    -- | Send the first component of the input through the argument
    --   arrow, and copy the rest unchanged to the output.
    first :: a b c -> a (b,d) (c,d)

    -- | A mirror image of 'first'.
    --
    --   The default definition may be overridden with a more efficient
    --   version if desired.
    second :: a b c -> a (d,b) (d,c)
    second f = arr swap >>> first f >>> arr swap
      where
        swap :: (x,y) -> (y,x)
        swap !(x,y) = (y,x)

    -- | Split the input between the two argument arrows and combine
    --   their output.  Note that this is in general not a functor.
    --
    --   The default definition may be overridden with a more efficient
    --   version if desired.
    (***) :: a b c -> a b' c' -> a (b,b') (c,c')
    f *** g = first f >>> second g

    -- | Fanout: send the input to both argument arrows and combine
    --   their output.
    --
    --   The default definition may be overridden with a more efficient
    --   version if desired.
    (&&&) :: a b c -> a b c' -> a b (c,c')
    f &&& g = arr (\b -> (b,b)) >>> f *** g

-- Ordinary functions are arrows.

instance Arrow F where
    arr f = F f
    first f = f *** identity
    second f = identity *** f
    (***) (F f) (F g) = F (\(x,y) -> (f x, g y))

-- | Kleisli arrows of a monad.
data Kleisli m a b = Kleisli { runKleisli :: a -> m b }

instance Category Monad m => (Kleisli m) where
    identity = Kleisli return
    o (Kleisli f) (Kleisli g) = Kleisli (\b -> g b >>= f)

instance Arrow Monad m => Kleisli m where
    arr f = Kleisli (return <~ f)
    first (Kleisli f) = Kleisli (\ !(b,d) -> f b >>= (\c -> return (c,d)))
    second (Kleisli f) = Kleisli (\ !(d,b) -> f b >>= (\c -> return (d,c)))

-- | The identity arrow, which plays the role of 'return' in arrow notation.
returnA :: Arrow a => a b b
returnA = arr id

-- | Precomposition with a pure function.
(^>>) :: Arrow a => (b -> c) -> a c d -> a b d
f ^>> a = arr f >>> a

-- | Postcomposition with a pure function.
(>>^) :: Arrow a => a b c -> (c -> d) -> a b d
a >>^ f = a >>> arr f

-- | Precomposition with a pure function (right-to-left variant).
(<<^) :: Arrow a => a c d -> (b -> c) -> a b d
a <<^ f = a <<< arr f

-- | Postcomposition with a pure function (right-to-left variant).
(^<<) :: Arrow a => (c -> d) -> a b c -> a b d
f ^<< a = arr f <<< a

class ArrowZero Arrow a => a where
    zeroArrow :: a b c

instance ArrowZero MonadPlus m => (Kleisli m) where
    zeroArrow = Kleisli (\_ -> mzero)

-- | A monoid on arrows.
class ArrowPlus ArrowZero a => a where
    -- | An associative operation with identity 'zeroArrow'.
    (<+>) :: a b c -> a b c -> a b c

instance ArrowPlus MonadPlus m => (Kleisli m) where
    Kleisli f <+> Kleisli g = Kleisli (\x -> f x `mplus` g x)

-- | Choice, for arrows that support it.  This class underlies the
-- @if@ and @case@ constructs in arrow notation.
-- Minimal complete definition: 'left', satisfying the laws
--
--  * @'left' ('arr' f) = 'arr' ('left' f)@
--
--  * @'left' (f >>> g) = 'left' f >>> 'left' g@
--
--  * @'left' f >>> 'arr' 'Left' = 'arr' 'Left' >>> f@
--
--  * @'left' f >>> 'arr' ('id' +++ g) = 'arr' ('id' +++ g) >>> 'left' f@
--
--  * @'left' ('left' f) >>> 'arr' 'assocsum' = 'arr' 'assocsum' >>> 'left' f@
--
-- where
--
-- > assocsum (Left (Left x)) = Left x
-- > assocsum (Left (Right y)) = Right (Left y)
-- > assocsum (Right z) = Right (Right z)
--
-- The other combinators have sensible default definitions, which may
-- be overridden for efficiency.

class ArrowChoice Arrow a => a where

    -- | Feed marked inputs through the argument arrow, passing the
    --   rest through unchanged to the output.
    left :: a b c -> a (Either b d) (Either c d)

    -- | A mirror image of 'left'.
    --
    --   The default definition may be overridden with a more efficient
    --   version if desired.
    right :: a b c -> a (Either d b) (Either d c)
    right f = arr mirror >>> left f >>> arr mirror
      where
        mirror :: Either x y -> Either y x
        mirror (Left x) = Right x
        mirror (Right y) = Left y

    -- | Split the input between the two argument arrows, retagging
    --   and merging their outputs.
    --   Note that this is in general not a functor.
    --
    --   The default definition may be overridden with a more efficient
    --   version if desired.
    (+++) :: a b c -> a b' c' -> a (Either b b') (Either c c')
    f +++ g = left f >>> right g

    -- | Fanin: Split the input between the two argument arrows and
    --   merge their outputs.
    --
    --   The default definition may be overridden with a more efficient
    --   version if desired.
    (|||) :: a b d -> a c d -> a (Either b c) d
    f ||| g = f +++ g >>> arr untag
      where
        untag (Left x) = x
        untag (Right y) = y

instance ArrowChoice F where
    left f = f +++ identity
    right f = identity +++ f
    F f +++ F g = F (Left <~ f) ||| F (Right <~ g)
    F f ||| F g  = F (\x -> either f g x) 

instance ArrowChoice Monad m => (Kleisli m) where
    left f = f +++ arr id
    right f = arr id +++ f
    f +++ g = (f >>> arr Left) ||| (g >>> arr Right)
    Kleisli f ||| Kleisli g = Kleisli (either f g)

-- | Some arrows allow application of arrow inputs to other inputs.
-- Instances should satisfy the following laws:
--
--  * @'first' ('arr' (\\x -> 'arr' (\\y -> (x,y)))) >>> 'app' = 'id'@
--
--  * @'first' ('arr' (g >>>)) >>> 'app' = 'second' g >>> 'app'@
--
--  * @'first' ('arr' (>>> h)) >>> 'app' = 'app' >>> h@
--
-- Such arrows are equivalent to monads (see 'ArrowMonad').

class ArrowApply Arrow a => a where
    app :: a (a b c, b) c

instance ArrowApply F where
    app = F (\(F f,x) -> f x)

instance ArrowApply Monad m => (Kleisli m) where
    app = Kleisli (\(Kleisli f, x) -> f x)

-- | The 'ArrowApply' class is equivalent to 'Monad': any monad gives rise
--   to a 'Kleisli' arrow, and any instance of 'ArrowApply' defines a monad.

data ArrowMonad a b = ArrowMonad (a () b)

instance Monad ArrowApply a => (ArrowMonad a) where
    return x = ArrowMonad (arr (\_ -> x))
    ArrowMonad m >>= f = ArrowMonad $
        m >>> arr (\x -> let ArrowMonad h = f x in (h, ())) >>> app

-- | Any instance of 'ArrowApply' can be made into an instance of
--   'ArrowChoice' by defining 'left' = 'leftApp'.

--leftApp :: ArrowApply a => a b c -> a (Either b d) (Either c d)
--leftApp f = arr ((\b -> (arr (\() -> b) >>> f >>> arr Left, ())) |||
--             (\d -> (arr (\() -> d) >>> arr Right, ()))) >>> app

-- | The 'loop' operator expresses computations in which an output value
-- is fed back as input, although the computation occurs only once.
-- It underlies the @rec@ value recursion construct in arrow notation.
-- 'loop' should satisfy the following laws:
--
-- [/extension/]
--      @'loop' ('arr' f) = 'arr' (\\ b -> 'fst' ('fix' (\\ (c,d) -> f (b,d))))@
--
-- [/left tightening/]
--      @'loop' ('first' h >>> f) = h >>> 'loop' f@
--
-- [/right tightening/]
--      @'loop' (f >>> 'first' h) = 'loop' f >>> h@
--
-- [/sliding/]
--      @'loop' (f >>> 'arr' ('id' *** k)) = 'loop' ('arr' ('id' *** k) >>> f)@
--
-- [/vanishing/]
--      @'loop' ('loop' f) = 'loop' ('arr' unassoc >>> f >>> 'arr' assoc)@
--
-- [/superposing/]
--      @'second' ('loop' f) = 'loop' ('arr' assoc >>> 'second' f >>> 'arr' unassoc)@
--
-- where
--
-- > assoc ((a,b),c) = (a,(b,c))
-- > unassoc (a,(b,c)) = ((a,b),c)
--
class ArrowLoop Arrow a => a where
    loop :: a (b,d) (c,d) -> a b c

--instance ArrowLoop F where
--    loop (F f) = F (\b -> let (c,d) = f (b,d) in c)

-- | Beware that for many monads (those for which the '>>=' operation
-- is strict) this instance will /not/ satisfy the right-tightening law
-- required by the 'ArrowLoop' class.
--instance ArrowLoop MonadFix m => (Kleisli m) where
--    loop (Kleisli f) = Kleisli (liftM fst . mfix . f')
--      where f' x y = f (x, snd y)

